home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr09 / ftetcged.zip / GED.PAS < prev   
Pascal/Delphi Source File  |  1993-06-01  |  6KB  |  235 lines
  1. PROGRAM FTEtc_To_GED;
  2. USES Crt,Dos,StrngLib,IOLib,TimeLib;
  3. CONST
  4.   MaxChildren =  12;
  5.   MaxFamilies = 200;
  6. TYPE
  7.   TFields = (OwnID,Sex,FatherID,MotherID,SpouseID,
  8.              MarriageCount,MarriageID,
  9.              MarriageLID,BirthLID,DeathLID,
  10.              MarriageDMY,BirthDMY,DeathDMY,OwnName,Spare,Last);
  11.   TFamily = RECORD
  12.              PopID,MomID : Word;
  13.              Date        : String[10];
  14.              Children    : Byte;
  15.              ChildID     : Array[1..MaxChildren] of Word;
  16.             END;
  17. CONST
  18.   FieldStart : Array[TFields] of Byte =
  19.                (1,4,5,8,11,14,15,18,22,26,30,39,48,57,83,87);
  20. VAR
  21.   DTime   : TDateTime;
  22.   Twirl   : Byte;
  23.   InFile,
  24.   OutFile : String;
  25.   InText  : String;
  26.   InUnit,
  27.   OutUnit : Text;
  28.   ID,i,j  : Word;
  29.   nFams   : Word;
  30.   Family  : Array[1..MaxFamilies] of TFamily;
  31.  
  32.   procedure Rotate;
  33.   const
  34.     Chars : Array[0..3] of Char = '-\|/';
  35.   begin
  36.     Twirl:=Succ(Twirl) mod 3;
  37.     Write(Chars[Twirl]);
  38.     GotoXY(Pred(WhereX),WhereY);
  39.   end;
  40.   function GetField(AField:TFields): String;
  41.   begin
  42.     GetField:=Copy(InText,FieldStart[AField],
  43.                    FieldStart[Succ(AField)]-FieldStart[AField]);
  44.   end;
  45.   function GetNumber(AField: TFields): Integer;
  46.   var
  47.     hold,err : Integer;
  48.   begin
  49.     Val(GetField(AField),hold,err);
  50.     GetNumber:=hold;
  51.   end;
  52.   function GetName: String;
  53.   var
  54.     i    : Byte;
  55.     hold : String;
  56.   begin
  57.     hold:=TrimStr(GetField(OwnName));
  58.     i:=Length(hold);
  59.     Repeat
  60.       Dec(i);
  61.     Until hold[i]=' ';
  62.     GetName:=Copy(hold,1,i)+'/'+Copy(hold,Succ(i),Length(hold)-i)+'/';
  63.   end;
  64.   function GetSex: String;
  65.   begin
  66.     If GetField(Sex)='1' then GetSex:='M'
  67.                          else GetSex:='F';
  68.   end;
  69.   function GetDate(AField: TFields): String;
  70.   var
  71.     i    : Byte;
  72.     hold : String;
  73.   begin
  74.     GetDate:='';
  75.     If not (AField in [MarriageDMY,BirthDMY,DeathDMY]) then Exit;
  76.     hold:=GetField(AField);
  77.     hold:=Copy(hold,1,2)+' '+Copy(hold,3,3)+' '+Copy(hold,6,4);
  78.     i:=1;
  79.   { While (i<=Length(hold)) and (hold[i] in ['?',' ']) do Inc(i); }
  80.     GetDate:=Copy(hold,i,Length(hold)-Pred(i));
  81.   end;
  82.  
  83. BEGIN
  84.   InFile:='';
  85.   If ParamCount=1 then
  86.   begin
  87.     OutFile:=UCase(ParamStr(1));
  88.     InFile:=OutFile+'.DB3';
  89.     OutFile:=OutFile+'.GED';
  90.   end;
  91.   Writeln('Ft-Etc 3.0 to GED conversion program by Kjell Eikland');
  92.   If (ParamCount<>1) or not FileExist(InFile) then
  93.   begin
  94.     Writeln('Syntax is: GED <FT-Etc.DataFile>');
  95.     Exit;
  96.   end;
  97.   Writeln('Using data from ',InFile);
  98.  
  99.   Assign(InUnit,InFile);
  100.  
  101.   Reset(InUnit);
  102.   Twirl:=0;
  103.   Write('Scanning for families ... ');
  104.   nFams:=0;
  105.   While not EOF(InUnit) do
  106.   begin
  107.     Readln(InUnit,InText);
  108.     Rotate;
  109.     If (GetSex='M') and (GetNumber(SpouseID)>0) then
  110.     begin
  111.       Inc(nFams);
  112.       With Family[nFams] do
  113.       begin
  114.         PopID:=GetNumber(OwnID);
  115.         MomID:=GetNumber(SpouseID);
  116.         Date:=GetDate(MarriageDMY);
  117.         Children:=0;
  118.       end;
  119.     end;
  120.   end;
  121.  
  122.   Reset(InUnit);
  123.   Twirl:=0;
  124.   Writeln;
  125.   Write('Scanning for children ... ');
  126.   While not EOF(InUnit) do
  127.   begin
  128.     Rotate;
  129.     Readln(InUnit,InText);
  130.     ID:=GetNumber(FatherID);
  131.     If GetNumber(FatherID)>0 then
  132.     begin
  133.       j:=GetNumber(MotherID);
  134.       i:=1;
  135.       While (Family[i].PopID<>ID) and
  136.             (Family[i].MomID<>j) do Inc(i);
  137.       With Family[i] do
  138.       begin
  139.         Inc(Children);    
  140.         ChildID[Children]:=GetNumber(OwnID);
  141.       end;
  142.     end;
  143.   end;
  144.  
  145.   Reset(InUnit);
  146.   Twirl:=0;
  147.   Now(DTime);
  148.   Writeln;
  149.   Write('Writing individuals ... ');
  150.   If FileExist(OutFile) then FileErase(OutFile);
  151.   Assign(OutUnit,OutFile);
  152.   Rewrite(OutUnit);
  153.   Writeln(OutUnit,'0 HEAD');
  154.   Writeln(OutUnit,'1 SOUR FT-ETC.');
  155.   Writeln(OutUnit,'2 VERS 3.0');
  156.   Writeln(OutUnit,'1 DEST PAF');
  157.   Writeln(OutUnit,'1 DATE '+MakePadStr(DTime.Day,2,'0')+' '+
  158.                             UCase(Copy(MonthName(DTime.Month,'E'),1,3))+' '+
  159.                             MakePadStr(DTime.Year,4,'0'));
  160.   Writeln(OutUnit,'1 CHAR IBMPC');
  161.   Writeln(OutUnit,'1 FILE '+OutFile);
  162.   While not EOF(InUnit) do
  163.   begin
  164.     Rotate;
  165.     Readln(InUnit,InText);
  166.     If GetNumber(MarriageCount)<2 then
  167.     begin
  168.       ID:=GetNumber(OwnID);
  169.       Writeln(OutUnit,'0 @I'+MakeStr(ID,0)+'@ INDI');
  170.       Writeln(OutUnit,'1 NAME '+GetName);
  171.       Writeln(OutUnit,'1 SEX '+GetSex);
  172.       If GetDate(BirthDMY)<>'' then
  173.       begin
  174.         Writeln(OutUnit,'1 BIRT');
  175.         Writeln(OutUnit,'2 DATE '+GetDate(BirthDMY));
  176.       end;
  177.       If GetDate(DeathDMY)<>'' then
  178.       begin
  179.         Writeln(OutUnit,'1 DEAT');
  180.         Writeln(OutUnit,'2 DATE '+GetDate(DeathDMY));
  181.       end;
  182.       If GetNumber(MarriageCount)>0 then
  183.       begin
  184.         If GetSex='M' then j:=1 else j:=0;
  185.         i:=0;
  186.         Repeat
  187.           Inc(i);
  188.           While (i<=nFams) and
  189.                 ((j=1) and (Family[i].PopID<>ID)) or
  190.                 ((j=0) and (Family[i].MomID<>ID)) do Inc(i);
  191.           If i<=nFams then
  192.             Writeln(OutUnit,'1 FAMS @F'+MakeStr(i,0)+'@');   { Own family }
  193.         Until i>nFams;
  194.       end;
  195.       ID:=GetNumber(FatherID);
  196.       If ID>0 then
  197.       begin
  198.         i:=1;
  199.         While (i<=nFams) and (Family[i].PopID<>ID) do Inc(i);
  200.         If i<=nFams then
  201.           Writeln(OutUnit,'1 FAMC @F'+MakeStr(i,0)+'@');   { Parent's family }
  202.       end;
  203.     end;
  204.   end;
  205.  
  206.   Twirl:=0;
  207.   Writeln;
  208.   Write('Writing families ... ');
  209.   For i:=1 to nFams do With Family[i] do
  210.   begin
  211.     Rotate;
  212.     Writeln(OutUnit,'0 @F'+MakeStr(i,0)+'@ FAM');
  213.     Writeln(OutUnit,'1 HUSB @I'+MakeStr(PopID,0)+'@');
  214.     Writeln(OutUnit,'1 WIFE @I'+MakeStr(MomID,0)+'@');
  215.  
  216.     For j:=1 to Children do
  217.       Writeln(OutUnit,'1 CHIL @I'+MakeStr(ChildID[j],0)+'@');
  218.  
  219.     If Date<>'' then
  220.     begin
  221.       Writeln(OutUnit,'1 MARR');
  222.       Writeln(OutUnit,'2 DATE '+Date);
  223.     end;
  224.   end;
  225.  
  226.   Writeln(OutUnit,'0 TRLR');
  227.  
  228.   Close(InUnit);
  229.   Close(OutUnit);
  230.  
  231.   Writeln;
  232.   Write('Done - Data saved in ',OutFile);
  233.  
  234. END.
  235.